Option Explicit
Private pWebAddress As String
'Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Dim xLanguge_No As Long, xLanguge__Lie As Long
Dim rng As Range
Dim xLanguge___No_Str As String
Dim Flag_there_are_spaces_in_the_target_language_cell As Long
Dim K_More_then_J As Long '''目标语言的内容 多于 原始的语言内容的单元格数目
Dim FILE_NAME_1 As String '文件名,无路径部分 ''' 如: About.html
Dim FILE_PATH_1 As String '文件名所在的路径部分 '''如 : E:\DG-1115\Pavo___Free Tailwind
Dim OpenFile As Variant
Dim text As String
Dim DiSe_Body As Long
Dim DiSe_Strong As Long
Dim DiSe_SuperLink As Long
Dim G_Row As Long
Dim G_Col As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call xLanguge__No_Initialize '''语种初始化,,
If Target.Columns.count = 1 And Target.Rows.count = 1 Then '选中 一个单元格
If Target.Value = "手工选择一个网页文件,解析之,提炼词组集合" Then
Call 手工选择一个网页文件__解析之__提炼词组集合
ElseIf Target.Value = "把目标语言词组写入源文件并下一个" Then
Call 把目标语言词组写入源文件_并下一个
ElseIf Target.Value = "把目标语言词组写入源文件" Then
Call 把目标语言词组写入源文件
ElseIf Target.Value = "GOOGLE翻译成目标语言" Then
Call GOOGLE翻译成目标语言
ElseIf Target.Value = "简要GOOGLE翻译成目标语言" Then
Call 简要GOOGLE翻译成目标语言
ElseIf Target.Value = "自动循环__Google谷歌灵活组块翻译" Then
Call 自动循环__Google谷歌灵活组块翻译(107, 135)
ElseIf Target.Value = "中文__Google谷歌灵活组块翻译" Then
Call 自动循环__Google谷歌灵活组块翻译(109, 109) ''109 只是中文
ElseIf Target.Value = "回到第一行" Then
Call 回到第一行00
ElseIf Target.Value = "【上一个】" Then
Call xxx【上一个】
ElseIf Target.Value = "【下一个】" Then
Call xxx【下一个】
Else
End If
Else
End If
'
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub 自动循环__Google谷歌灵活组块翻译(ByVal BEG_HANG As Long, ByVal END_HANG As Long)
' BEG_HANG = 109 ''只是中文
' END_HANG = 109
'
' BEG_HANG = 107
' END_HANG = 135
Dim t As String
Dim arr1
' xLanguge_No = xLanguge_No + 1: xLanguge__Lie = 2
Dim k As Long
' Dim BEG_HANG, END_HANG As Long ''除了英语以外的其他语言所在的开始行,结束行
''优先检测源数组的单元格中是否含有特殊字符:如:%
t = EfficientlyCheckPercentInColumnJ
If t = "包含%" Then
MsgBox "K 列 的有效单元格中 包含 【%】 字符! ,提前结束本次的 【自动循环__Google谷歌灵活组块翻译】"
Exit Sub
Else
End If
'
Cells(41, 1) = "" '''清空
For k = BEG_HANG To END_HANG '''逐个语言的翻译,并写入目标语言的html文件
xLanguge_No = k
xLanguge___No_Str = Cells(xLanguge_No, xLanguge__Lie).Value
Cells(21, 2) = xLanguge___No_Str
'folderPath = "E:\G-0501\www.backlack.com\News"
t = Left(Cells(1, 1), (InStr(Cells(1, 1), ".com") - 1)) & ".com\zh-CN" ''iFILE_PATH1 = Cells(1, 1) ''E:\, G-0501\www.10JNEX900.com 或 "E:\G-0501\www.backlack.com\News"
If Dir(t, vbDirectory) = "" And InStr(xLanguge___No_Str, "中文") > 0 Then ''要翻译成中文,可是没有目标的文件夹,则跳过......Return________中文中文
Else
Call Google谷歌灵活组块翻译(Function_Get_Target_Lang(Cells(k, 2)), 10, 11)
' Call 回到第一行00
Range("A1:K1").Select
Call 备份某个网页的内容
Call 把目标语言词组写入源文件
Cells(41, 1) = k & "/" & END_HANG & ",当前语言【" & Right(Cells(k, 2), Len(Cells(k, 2)) - (InStrRev(Cells(k, 2), "_") + 0)) & "】翻译完毕,并写入目标语言html文件中 "
Cells(21, 2) = Cells(21, 2)
End If
Next k
If xLanguge_No > (END_HANG - 1) Then
MsgBox "最后一个语言了,,,,Max rows Reached"
xLanguge_No = END_HANG
''随机颜色
''
' 如果生成 2-9之间的随机数
'p2 = Int(2 + 9 * Rnd()) - -错误的
'p2 = Int(2 + (9 - 2 + 1) * Rnd()) - ---正确
arr1 = Array(6, 45, 38, 36, 35, 37, 39, 40, 41, 42, 7, 15) '颜色列表
Range("A137:C137").Select
Range("C137").Activate
' Selection.Interior.ColorIndex = arr1(Int(1 + (9 - 1 + 1) * Rnd()))
Selection.Interior.ColorIndex = Int(3 + (56 - 3 + 1) * Rnd())
Exit Sub
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' 某个语音:xxxLanguge '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' 源数据所在的列:FR_Lie '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' 目标数据所在的列:TO_Lie '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Google谷歌灵活组块翻译(ByVal xxxLanguge As String, ByVal FR_Lie As Long, ByVal TO_Lie As Long)
Dim lastRow As Long
Dim i, iii, k As Long
Dim sourceTexts As String
Dim sourceArray() As String
Dim translatedArray() As String
Dim nonEmptyResults() As String
Dim http As Object
Dim url As String
Dim d As String
Dim responseText As String
Dim startPos As Long
Dim endPos As Long
Dim charLimit As Long
charLimit = 4920 ' ''''''''谷歌翻译字符限制
Dim aaa, bbb, t0A, dttt As Long
Dim translatedResults As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("解析网页,提炼词组,翻译词组,写入文件") 'ActiveSheet
' 清空B列的内容
' ws.Columns("B").Clear
ws.Columns(TO_Lie).Clear '''ws.Columns("L").Clear
'
Debug.Print "...............: "
Debug.Print ".....|||||||||||||||||||||||||||..: "
' 获取 A 列最后一个非空单元格的行号
lastRow = Cells(Rows.count, FR_Lie).End(xlUp).Row
' 创建一个 XMLHTTP 对象
Set http = CreateObject("MSXML2.XMLHTTP")
dttt = 1
i = 1
Do While i <= lastRow
sourceTexts = ""
Dim currentCharCount As Integer
currentCharCount = 0
Dim startIndex As Long
startIndex = i
Dim validCellCount As Integer
validCellCount = 0
' 构建不超过字符限制的源文本,保证单元格内容完整
Do While i <= lastRow
If Cells(i, FR_Lie).Value <> "" Then
Dim cellText As String
cellText = Cells(i, FR_Lie).Value
Dim EncodedText As String
EncodedText = Replace(cellText, " ", "+")
If currentCharCount + Len(EncodedText) + 3 <= charLimit Then ' 3 是 "%0A" 的长度
sourceTexts = sourceTexts & EncodedText & "%0A" & "%0A" & "%0A" '''多个%0A,,避免随机的多翻译原单元格【现象】.
currentCharCount = currentCharCount + Len(EncodedText) + 3 + 3 + 3
validCellCount = validCellCount + 1
i = i + 1
Else
Debug.Print "......大于字数限制次数..: " & dttt
Debug.Print sourceTexts
dttt = dttt + 1
Exit Do
End If
Else
i = i + 1
End If
Loop
If sourceTexts <> "" Then
' 去除最后的换行符
sourceTexts = Left(sourceTexts, Len(sourceTexts) - 3 - 3 - 3) ''多个%0A,,,
ReDim sourceArray(0 To validCellCount - 1)
ReDim translatedArray(0 To validCellCount - 1)
' 填充源数组
Dim j As Integer
j = 0
For k = startIndex To i - 1
If Cells(k, FR_Lie).Value <> "" Then
sourceArray(j) = Cells(k, FR_Lie).Value
j = j + 1
End If
Next k
' 构建谷歌翻译的 URL
url = "https://translate.google.com/m?hl=zh-CN&sl=auto&tl=" & xxxLanguge & "&q=" & sourceTexts
' WebUrl = "https://translate.google.com/?hl=zh-CN&sl=auto&tl=" & tLang & "&text=" & TTT & "&op=translate"
' 发送 HTTP 请求
http.Open "GET", url, False
http.send
' 获取响应文本
responseText = http.responseText
'
'Debug.Print "Request Body: " & responseText
'Debug.Print "URL: " & url
' 处理响应文本提取翻译结果
startPos = InStr(responseText, "
") '''开头标志代码
If startPos > 0 Then
startPos = startPos + Len("
")
endPos = InStr(startPos, responseText, "
")
If endPos > 0 Then
d = Mid(responseText, startPos, endPos - startPos)
' 按LF字符拆分文件内容为行数组
' d = Replace(d, vbLfCrLf, vbLf)
' d = Replace(d, vbLfCrLf, vbLf)
translatedResults = Split(d, vbLf) ' vbLf 表示 LF 字符
' 剔除数组中的空元素
j = 0
ReDim nonEmptyResults(0 To UBound(translatedResults)) ' 初始化动态数组
For iii = LBound(translatedResults) To UBound(translatedResults)
If Trim(translatedResults(iii)) <> "" Then ' 检查是否为空行
nonEmptyResults(j) = translatedResults(iii) ' 将非空行存入新数组
j = j + 1
End If
Next iii
ReDim Preserve nonEmptyResults(0 To j - 1) ' 调整数组大小为实际非空行数
ReDim Preserve translatedResults(0 To j - 1) ' 调整数组大小为实际非空行数
' 将非空行内容写入B列
For iii = LBound(nonEmptyResults) To UBound(nonEmptyResults)
translatedResults(iii) = nonEmptyResults(iii) ' 从第1行开始写入
Next iii
End If
End If
' If dttt = 9 Then
' Debug.Print "...............: ------有空格出项:::"
' Debug.Print d
' dttt = dttt
' End If
' 将翻译结果写入 B 列对应的单元格
j = 0
For k = LBound(nonEmptyResults) To UBound(nonEmptyResults)
If Cells(k + startIndex, FR_Lie).Value <> "" Then
Cells(k + startIndex, TO_Lie).Value = translatedResults(j)
j = j + 1
End If
Next k
i = startIndex + (UBound(nonEmptyResults) + 1 - LBound(nonEmptyResults)) ''重塑定位
'
End If
Loop
' 释放对象
Set http = Nothing
' 将 K 列 的内容垂直居中对齐
' 获取 K 列的最后一行
lastRow = ws.Cells(ws.Rows.count, "K").End(xlUp).Row
' 选择 K 列的第1行到最后一行
ws.Range("K1:K" & lastRow).VerticalAlignment = xlCenter
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub xLanguge__No_Initialize()
' xLanguge_No = 10:
xLanguge__Lie = 2
If xLanguge_No < 106 Then
xLanguge_No = 106
ElseIf xLanguge_No > 135 Then
xLanguge_No = 135
Else
End If
xLanguge___No_Str = Cells(xLanguge_No, xLanguge__Lie).Value
Cells(21, 2) = xLanguge___No_Str
'
'
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'~~> Next Button
Private Sub xxx【下一个】()
Dim arr1
xLanguge_No = xLanguge_No + 1: xLanguge__Lie = 2
If xLanguge_No > 135 Then
MsgBox "最后一个语言了,,,,Max rows Reached"
xLanguge_No = 135
''随机颜色
''
' 如果生成 2-9之间的随机数
'p2 = Int(2 + 9 * Rnd()) - -错误的
'p2 = Int(2 + (9 - 2 + 1) * Rnd()) - ---正确
arr1 = Array(6, 45, 38, 36, 35, 37, 39, 40, 41, 42, 7, 15) '颜色列表
Range("A137:C137").Select
Range("C137").Activate
' Selection.Interior.ColorIndex = arr1(Int(1 + (9 - 1 + 1) * Rnd()))
Selection.Interior.ColorIndex = Int(3 + (56 - 3 + 1) * Rnd())
Exit Sub
End If
' Call 回到第一行00
Range("A1:K1").Select
xLanguge___No_Str = Cells(xLanguge_No, xLanguge__Lie).Value
Cells(21, 2) = xLanguge___No_Str
Call 备份某个网页的内容
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'~~> Previous Button
Private Sub xxx【上一个】()
Dim arr1
xLanguge_No = xLanguge_No - 1: xLanguge__Lie = 2
If xLanguge_No < 106 Then
MsgBox "最前一个语言了,,,,1st Row Reached"
xLanguge_No = 106
''随机颜色
''
' 如果生成 2-9之间的随机数
'p2 = Int(2 + 9 * Rnd()) - -错误的
'p2 = Int(2 + (9 - 2 + 1) * Rnd()) - ---正确
arr1 = Array(6, 45, 38, 36, 35, 37, 39, 40, 41, 42, 7, 15, 18, 20, 25, 28, 30, 32) '颜色列表
Range("A137:C137").Select
Range("C137").Activate
' Selection.Interior.ColorIndex = arr1(Int(1 + (9 - 1 + 1) * Rnd()))
Selection.Interior.ColorIndex = Int(3 + (56 - 3 + 1) * Rnd())
Exit Sub
End If
' Call 回到第一行00
Range("A1:K1").Select
xLanguge___No_Str = Cells(xLanguge_No, xLanguge__Lie).Value
Cells(21, 2) = xLanguge___No_Str
Call 备份某个网页的内容
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub 备份某个网页的内容()
Dim text As String
Dim c As String
Dim len1, len2, len3, i_JianTou_L, i_JianTou_R, iNeedReplace, lastRow_E, lastRow_J, lastRow_K As Long
Dim xText2, tt1_L, tt1_R, KKK As String
Dim n, n0, n1, n2, n3, i, nnn, nKK, ddd, L1, L2, MM, n1_L, n1R, n1_R, n2_L, n2_LL, ppp As Long
Dim X, a, b, t11, yy, xText, t1, t1R, t2, xMark, yText As String
Dim xxxFileName, xxxWebName, Subdirectory_Name As String
Dim iFile_Name1, iFILE_PATH1, iFile_Tatol_Name1, iFile_Name2, iFILE_PATH2, iFile_Tatol_Name2, tLang As String
Dim WebUrl As String
Dim sheet As Worksheet
Dim Mark_Cell, Beg_Cell, Beg2_Cell, End_Cell, Text_Cell, Input_Cell, ByteNo_Cell, Text_Cell_Optimize As Range
Dim DDD1, DDD2, DDD3 As String
Dim tHH, tJJ, tKK As String
'''备份某个网页的内容
'读取当前选择的文件名和路径
'
iFile_Tatol_Name1 = Cells(1, 3) ''E:\, G-0501\www.10JNEX900.com\10JNEX900.html
iFile_Name1 = Cells(1, 2) ''10JNEX900.html
iFILE_PATH1 = Cells(1, 1) ''E:\, G-0501\www.10JNEX900.com
'目标语言的文件名和路径
'
'读取目标语言 '
tLang = Function_Get_Target_Lang(Cells(21, 2))
If tLang = "nonono_Lang" Then
MsgBox "目标语言为空,,, 请选择先,,"
Exit Sub
ElseIf tLang = "Return________中文中文" Then ''''中文,,,特殊处理。。。。有的网站代码没有这个语言
MsgBox "目标语言为 【中文】,,跳过。。。。"
Exit Sub
Else
End If
If InStr(iFILE_PATH1, "\" & tLang) Then '错误地 选了目标语言的文件,
MsgBox "错误地选了某个目标语言的文件,xxxxxx, 要求选择源语言文件。。。"
Exit Sub
Else
Subdirectory_Name = "News" '子目录名字
If InStr(iFILE_PATH1, Subdirectory_Name) Then
iFile_Name2 = iFile_Name1 '目标文件名
iFILE_PATH2 = Left(iFILE_PATH1, InStr(iFILE_PATH1, "\" & Subdirectory_Name) - 1) & "\" & tLang '目标路径
iFile_Tatol_Name2 = iFILE_PATH2 & "\" & Subdirectory_Name & "\" & iFile_Name2 '目标文件名的全路径
Else
iFile_Name2 = iFile_Name1 '目标文件名
iFILE_PATH2 = iFILE_PATH1 & "\" & tLang '目标路径
iFile_Tatol_Name2 = iFILE_PATH2 & "\" & iFile_Name2 '目标文件名的全路径
End If
End If
'读文件内容,并修改/替换 局部内容
xText = ReadFileTe000xt000(iFile_Tatol_Name2)
'写文件
Call WriteFileText(xText, "E:\, G-0501\临时某个页面的代码.html") ''
End Sub
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub 回到第一行00()
ActiveWindow.ScrollRow = 1 '''将指定的工作表滚动到顶部
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GOOGLE翻译成目标语言()
'
'
Dim text As String
Dim c As String
Dim len1, len2, len3, i_JianTou_L, i_JianTou_R, iNeedReplace, iiii, lastRow_J, lastRow_K As Long
Dim xText2, tt1_L, tt1_R, KKK As String
Dim n, n0, n1, n2, n3, i, nnn, nKK, ddd, L1, L2, MM, n1_L, n1R, n1_R, n2_L, n2_LL, ppp As Long
Dim X, a, b, t11, yy, xText, t1, t1R, t2, xMark, yText As String
Dim xxxFileName, xxxWebName, Subdirectory_Name As String
Dim iFile_Name1, iFILE_PATH1, iFile_Tatol_Name1, iFile_Name2, iFILE_PATH2, iFile_Tatol_Name2, tLang, d, TTT As String
Dim WebUrl As String
Dim sheet As Worksheet
Dim Mark_Cell, Beg_Cell, Beg2_Cell, End_Cell, Text_Cell, Input_Cell, ByteNo_Cell, Text_Cell_Optimize As Range
Application.ScreenUpdating = False
Set sheet = ActiveWorkbook.Sheets("解析网页,提炼词组,翻译词组,写入文件")
'读取目标语言 '
tLang = Function_Get_Target_Lang(Cells(21, 2))
If tLang = "nonono_Lang" Then
MsgBox "目标语言为空,,, 请选择先,,"
Exit Sub
Else
End If
'
'居中
'
Range("E1:M300").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
''清空内容和格式
Range("K65000").Select
Selection.Copy
lastRow_K = MaxUsedRowInCol("K")
Range("K" & Trim(str(1)) & ":K" & Trim(str(lastRow_K))).Select
Range("K" & Trim(str(lastRow_K))).Activate
ActiveSheet.Paste
Range("K1").Select
'更新 目标那行的总行数
nnn = MaxUsedRowInCol("E") + 0
'
'排序,
'
Range("E1:K" & Trim(str(nnn))).Select
Range("E" & Trim(str(nnn))).Activate
Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Key2:=Range("F1"), Order2:=xlAscending, Key3:=Range("H1"), Order3:=xlAscending, header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Range("H5").Select
Range("E" & Trim(str(1)) & ":I" & Trim(str(nnn))).Select
Selection.Interior.ColorIndex = xlNone '''底色 白色
Range("K" & Trim(str(1)) & ":K" & Trim(str(1))).Select
''https://translate.google.com/?hl=zh-CN&sl=auto&tl=fr&text=Home%20%0AAbout%20us%0AProducts%0AServices%0ANews%0AContact&op=translate
''https://translate.google.com/?hl=zh-CN&sl=auto&tl=fr&text=About%20us%0AContact%0ANews%0A&op=translate
lastRow_J = MaxUsedRowInCol("J") + 0
TTT = ""
For i = 1 To lastRow_J
If Len(TTT) < 5000 Then '''(谷歌翻译默认是5000个字符上限)
If Cells(i, 10) = "" Then '10---J列,, 优化的词组
'MsgBox str(i) & "行 的 str(cells(i,10)) 为空格,..请检查。。。 "
Exit For
Else
d = Replace(Range("J" & Trim(str(i))), " ", "%20") '空格置换 为 %20
' d = Replace(Range("J" & Trim(str(i))), "? ", "%20") '?置换 为 %20
If i = 1 Then
TTT = d
Else
TTT = TTT & "%0A" & d '加连接符号 %0A
End If
End If
Else
End If
Next
'清空
Range("K1:K1000").Select
Range("K1000").Activate
Selection.ClearContents
'Selection.Interior.ColorIndex = xlNone '''底色 白色
Range("K1").Select
'打开Chrome浏览器的翻译网址
'
WebUrl = "https://translate.google.com/?hl=zh-CN&sl=auto&tl=" & tLang & "&text=" & TTT & "&op=translate"
WebUrl = WebUrl
' Shell ("C:\Program Files\Google\Chrome\Application\chrome.exe -url " & WebUrl) 'C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe --disable-background-networking --user-data-dir="C:\Users\Administrator\AppData\Local\MyChrome\Chrome\MyData"
Shell ("C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe -url " & WebUrl) 'C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe --disable-background-networking --user-data-dir="C:\Users\Administrator\AppData\Local\MyChrome\Chrome\MyData"
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GOOGLE翻译成目标语言_____下一部分内容()
Dim text As String
Dim c As String
Dim len1, len2, len3, i_JianTou_L, i_JianTou_R, iNeedReplace, lastRow_J As Long
Dim xText2, tt1_L, tt1_R, KKK As String
Dim n, n0, n1, n2, n3, i, nnn, nKK, ddd, L1, L2, MM, n1_L, n1R, n1_R, n2_L, n2_LL, ppp As Long
Dim X, a, b, t11, yy, xText, t1, t1R, t2, xMark, yText As String
Dim xxxFileName, xxxWebName, Subdirectory_Name As String
Dim iFile_Name1, iFILE_PATH1, iFile_Tatol_Name1, iFile_Name2, iFILE_PATH2, iFile_Tatol_Name2, tLang, d, TTT As String
Dim WebUrl As String
Dim sheet As Worksheet
Dim Mark_Cell, Beg_Cell, Beg2_Cell, End_Cell, Text_Cell, Input_Cell, ByteNo_Cell, Text_Cell_Optimize As Range
Application.ScreenUpdating = False
Set sheet = ActiveWorkbook.Sheets("解析网页,提炼词组,翻译词组,写入文件")
'读取目标语言 '
tLang = Function_Get_Target_Lang(Cells(21, 2))
If tLang = "nonono_Lang" Then
MsgBox "目标语言为空,,, 请选择先,,"
Exit Sub
Else
End If
Dim iK As Long
iK = MaxUsedRowInCol("K") + 0 - 0
''开始的这一行 加底色,,
'
Range("J" & Trim(str(iK)) & ":K" & Trim(str(iK))).Select
Selection.Interior.ColorIndex = 55 '''底色 深蓝色
Selection.Font.ColorIndex = 3 ''红色
Selection.Font.Bold = True ''粗体
Range("K" & Trim(str(iK))).Select
lastRow_J = MaxUsedRowInCol("J") + 0
''https://translate.google.com/?hl=zh-CN&sl=auto&tl=fr&text=Home%20%0AAbout%20us%0AProducts%0AServices%0ANews%0AContact&op=translate
''https://translate.google.com/?hl=zh-CN&sl=auto&tl=fr&text=About%20us%0AContact%0ANews%0A&op=translate
TTT = ""
For i = iK To lastRow_J
If Range("J" & Trim(str(i))) = "" Then ' J列,, 优化的词组
'MsgBox str(i) & "行 的 str(cells(i,10)) 为空格,..请检查。。。 "
Exit For
Else
d = Replace(Range("J" & Trim(str(i))), " ", "%20") '空格置换 为 %20
' d = Replace(Range("J" & Trim(str(i))), "? ", "%20") '?置换 为 %20
If i = 1 Then
TTT = d
Else
TTT = TTT & "%0A" & d '加连接符号 %0A
End If
End If
Next
'打开Chrome浏览器的翻译网址
'
WebUrl = "https://translate.google.com/?hl=zh-CN&sl=auto&tl=" & tLang & "&text=" & TTT & "&op=translate"
WebUrl = WebUrl
' Shell ("C:\Program Files\Google\Chrome\Application\chrome.exe -url " & WebUrl) 'C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe --disable-background-networking --user-data-dir="C:\Users\Administrator\AppData\Local\MyChrome\Chrome\MyData"
Shell ("C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe -url " & WebUrl) 'C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe --disable-background-networking --user-data-dir="C:\Users\Administrator\AppData\Local\MyChrome\Chrome\MyData"
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Function_Get_Target_Lang(ByVal xCells As String) As String
Dim tLang As String
If xCells = "Return_French_____法语" Then
tLang = "fr"
ElseIf xCells = "Return_Spanish____西班牙" Then
tLang = "es"
ElseIf xCells = "Return_Deutsch____德语" Then
tLang = "de"
ElseIf xCells = "Return_Italian______意大利" Then
tLang = "it"
ElseIf xCells = "Return_Japanese___日本语" Then
tLang = "ja"
ElseIf xCells = "Return_Thailand___泰国" Then
tLang = "th"
ElseIf xCells = "Return_Russian____俄罗斯" Then
tLang = "ru"
ElseIf xCells = "Return_Portuguese_葡萄牙语" Then
tLang = "pt"
ElseIf xCells = "Return_Turkish____土耳其" Then
tLang = "tr"
ElseIf xCells = "Return_pl___波兰语" Then
tLang = "pl"
ElseIf xCells = "Return_sl___斯洛文尼亚语" Then
tLang = "sl"
ElseIf xCells = "Return_cs___捷克语" Then
tLang = "cs"
ElseIf xCells = "Return_no___挪威语" Then
tLang = "no"
ElseIf xCells = "Return_iw___希伯来语" Then
tLang = "iw"
ElseIf xCells = "Return_id___印尼语" Then
tLang = "id"
ElseIf xCells = "Return_nl___荷兰语" Then
tLang = "nl"
ElseIf xCells = "Return_da___丹麦语" Then
tLang = "da"
ElseIf xCells = "Return________中文中文" Then
tLang = "zh-CN"
ElseIf xCells = "Return_hu___匈牙利语" Then
tLang = "hu"
ElseIf xCells = "Return_ch___瑞士" Then
tLang = "ch"
ElseIf xCells = "Return_fi___芬兰语" Then
tLang = "fi"
ElseIf xCells = "Return_Vietnamese_越南" Then
tLang = "vi"
ElseIf xCells = "Return_uk___乌克兰语" Then
tLang = "uk"
ElseIf xCells = "Return_ar___阿拉伯语" Then
tLang = "ar"
ElseIf xCells = "Return_el___希腊语" Then
tLang = "el"
ElseIf xCells = "Return_bg___保加利亚语" Then
tLang = "bg"
ElseIf xCells = "Return_sv___瑞典语" Then
tLang = "sv"
ElseIf xCells = "Return_sk___斯洛伐克语" Then
tLang = "sk"
ElseIf xCells = "Return_ko___韩语" Then
tLang = "ko"
Else
tLang = "nonono_Lang"
End If
Function_Get_Target_Lang = tLang
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub 简要GOOGLE翻译成目标语言()
'
'
Dim text As String
Dim c As String
Dim len1, len2, len3, i_JianTou_L, i_JianTou_R, iNeedReplace As Long
Dim xText2, tt1_L, tt1_R, KKK As String
Dim n, n0, n1, n2, n3, i, nnn, nKK, ddd, L1, L2, MM, n1_L, n1R, n1_R, n2_L, n2_LL, ppp As Long
Dim X, a, b, t11, yy, xText, t1, t1R, t2, xMark, yText As String
Dim xxxFileName, xxxWebName, Subdirectory_Name As String
Dim iFile_Name1, iFILE_PATH1, iFile_Tatol_Name1, iFile_Name2, iFILE_PATH2, iFile_Tatol_Name2, tLang, d, TTT As String
Dim WebUrl As String
Dim sheet As Worksheet
Dim Mark_Cell, Beg_Cell, Beg2_Cell, End_Cell, Text_Cell, Input_Cell, ByteNo_Cell, Text_Cell_Optimize As Range
Set sheet = ActiveWorkbook.Sheets("解析网页,提炼词组,翻译词组,写入文件")
'读取目标语言 '
tLang = Function_Get_Target_Lang(Cells(21, 2))
If tLang = "nonono_Lang" Then
MsgBox "目标语言为空,,, 请选择先,,"
Exit Sub
Else
End If
''
'' '读取目标语言
'' '
'' If Cells(21, 2) = "Return_French_____法语" Then
'' tLang = "fr"
'' ElseIf Cells(21, 2) = "Return_Spanish____西班牙" Then
'' tLang = "es"
'' ElseIf Cells(21, 2) = "Return_Deutsch____德语" Then
'' tLang = "de"
'' ElseIf Cells(21, 2) = "Return_Italian______意大利" Then
'' tLang = "it"
'' ElseIf Cells(21, 2) = "Return_Japanese___日本语" Then
'' tLang = "ja"
'' ElseIf Cells(21, 2) = "Return_Thailand___泰国" Then
'' tLang = "th"
'' ElseIf Cells(21, 2) = "Return_Russian____俄罗斯" Then
'' tLang = "ru"
'' ElseIf Cells(21, 2) = "Return_Portuguese_葡萄牙语" Then
'' tLang = "pt"
'' ElseIf Cells(21, 2) = "Return_Turkish____土耳其" Then
'' tLang = "tr"
'' ElseIf Cells(21, 2) = "Return_pl___波兰语" Then
'' tLang = "pl"
'' ElseIf Cells(21, 2) = "Return_sl___斯洛文尼亚语" Then
'' tLang = "sl"
'' ElseIf Cells(21, 2) = "Return_cs___捷克语" Then
'' tLang = "cs"
'' ElseIf Cells(21, 2) = "Return_no___挪威语" Then
'' tLang = "no"
'' ElseIf Cells(21, 2) = "Return_iw___希伯来语" Then
'' tLang = "iw"
'' ElseIf Cells(21, 2) = "Return_id___印尼语" Then
'' tLang = "id"
'' ElseIf Cells(21, 2) = "Return_nl___荷兰语" Then
'' tLang = "nl"
'' ElseIf Cells(21, 2) = "Return_da___丹麦语" Then
'' tLang = "da"
'' ElseIf Cells(21, 2) = "Return________中文中文" Then
'' tLang = "zh-CN"
'' ElseIf Cells(21, 2) = "Return_hu___匈牙利语" Then
'' tLang = "hu"
'' ElseIf Cells(21, 2) = "Return_ch___瑞士" Then
'' tLang = "ch"
'' ElseIf Cells(21, 2) = "Return_fi___芬兰语" Then
'' tLang = "fi"
'' ElseIf Cells(21, 2) = "Return_Vietnamese_越南" Then
'' tLang = "vi"
'' ElseIf Cells(21, 2) = "Return_uk___乌克兰语" Then
'' tLang = "uk"
'' ElseIf Cells(21, 2) = "Return_ar___阿拉伯语" Then
'' tLang = "ar"
'' ElseIf Cells(21, 2) = "Return_el___希腊语" Then
'' tLang = "el"
'' ElseIf Cells(21, 2) = "Return_bg___保加利亚语" Then
'' tLang = "bg"
'' ElseIf Cells(21, 2) = "Return_sv___瑞典语" Then
'' tLang = "sv"
'' ElseIf Cells(21, 2) = "Return_sk___斯洛伐克语" Then
'' tLang = "sk"
'' ElseIf Cells(21, 2) = "Return_ko___韩语" Then
'' tLang = "ko"
'' Else
'' MsgBox "目标语言为空,,, 请选择先,,"
'' Exit Sub
'' End If
TTT = "english"
'清空
Range("K1:K600").Select
Range("K600").Activate
Selection.ClearContents
'Selection.Interior.ColorIndex = xlNone '''底色 白色
Range("K1").Select
'打开Chrome浏览器的翻译网址
'
WebUrl = "https://translate.google.com/?hl=zh-CN&sl=auto&tl=" & tLang & "&text=" & TTT & "&op=translate"
WebUrl = WebUrl
' Shell ("C:\Program Files\Google\Chrome\Application\chrome.exe -url " & WebUrl) 'C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe --disable-background-networking --user-data-dir="C:\Users\Administrator\AppData\Local\MyChrome\Chrome\MyData"
Shell ("C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe -url " & WebUrl) 'C:\Users\Administrator\AppData\Local\MyChrome\Chrome\Application\chrone.exe --disable-background-networking --user-data-dir="C:\Users\Administrator\AppData\Local\MyChrome\Chrome\MyData"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub 把目标语言词组写入源文件_并下一个() '
Dim lastRow_J, lastRow_K As Long
Flag_there_are_spaces_in_the_target_language_cell = 0 '''清0,,,目标语言单元格存在空格 与否
K_More_then_J = 0 ''目标语言的内容 多于 原始的语言内容的单元格数目
Call 把目标语言词组写入源文件
If K_More_then_J = 0 Then ''目标语言的内容 小于等于 原始的语言内容的单元格数目
If Flag_there_are_spaces_in_the_target_language_cell = 0 Then ''不存在空格
lastRow_J = MaxUsedRowInCol("J")
lastRow_K = MaxUsedRowInCol("K")
If lastRow_J = lastRow_K Then
If Cells(21, 2) = "Return_sk___斯洛伐克语" Then '''
MsgBox "目标语言为 没有下一个了,,,,,," & vbCrLf & vbCrLf & " 。。"
Exit Sub
Else
Call xxx【下一个】
Call GOOGLE翻译成目标语言
End If
Else
If lastRow_K > 0 Then
Call GOOGLE翻译成目标语言_____下一部分内容
Else
End If
End If
Else
End If
Else
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ReadFileTe000xt000(ByVal FilePath As String) As String
Dim fs, f, ts, s, t1, t2, Ii, SText
Dim AD As Object: Set AD = CreateObject("ADODB.Stream")
AD.Charset = "utf-8"
AD.Open
AD.LoadFromFile FilePath
ReadFileTe000xt000 = AD.readText
AD.Close
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub 把目标语言词组写入源文件()
' '
Dim text As String
Dim c As String
Dim len1, len2, len3, i_JianTou_L, i_JianTou_R, iNeedReplace, lastRow_E, lastRow_J, lastRow_K As Long
Dim xText2, tt1_L, tt1_R, KKK As String
Dim n, n0, n1, n2, n3, i, nnn, nKK, ddd, L1, L2, MM, n1_L, n1R, n1_R, n2_L, n2_LL, ppp As Long
Dim X, a, b, t11, yy, xText, t1, t1R, t2, xMark, yText As String
Dim xxxFileName, xxxWebName, Subdirectory_Name As String
Dim iFile_Name1, iFILE_PATH1, iFile_Tatol_Name1, iFile_Name2, iFILE_PATH2, iFile_Tatol_Name2, tLang As String
Dim WebUrl As String
Dim sheet As Worksheet
Dim Mark_Cell, Beg_Cell, Beg2_Cell, End_Cell, Text_Cell, Input_Cell, ByteNo_Cell, Text_Cell_Optimize As Range
Dim DDD1, DDD2, DDD3 As String
Dim tHH, tJJ, tKK As String
' 设置工作表为当前活动工作表
Dim cell As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rng As Range
' 剔除旧的语言单元格和新的目标语言的单元格,都为空的时候
'
'
''判断连续的几个单元格中有没有空白的单元格存在,
lastRow_K = MaxUsedRowInCol("K") + 0
Set rng = ws.Range("K" & Trim(str(1)) & ":K" & Trim(str(lastRow_K))) ' 修改此范围以适应你需要检查的单元格区域
' 设置要检查的单元格区域,例如A1:Z100
Set rng = ws.Range("K" & Trim(str(1)) & ":K" & Trim(str(lastRow_K)))
For Each cell In rng
' 检查单元格是否为空
If IsEmpty(cell) And IsEmpty(cell.Offset(0, -1)) Then
' 设置单元格背景颜色为淡黄色.....
Range("E" & Trim(str(cell.Row)) & ":K" & Trim(str(cell.Row))).Select
Selection.Delete Shift:=xlUp
' Flag_there_are_spaces_in_the_target_language_cell = 1 '''目标语言单元格存在空格
End If
Next cell
''判断连续的几个单元格中有没有空白的单元格存在,
lastRow_K = MaxUsedRowInCol("K") + 0
If Application.WorksheetFunction.CountBlank(rng) > 0 Then
' 设置要检查的单元格区域,例如A1:Z100
Set rng = ws.Range("K" & Trim(str(1)) & ":K" & Trim(str(lastRow_K)))
' 遍历单元格区域
' Dim cell As Range
For Each cell In rng
' 检查单元格是否为空
If IsEmpty(cell) Then
' 设置单元格背景颜色为淡黄色.....
cell.Interior.Color = RGB(255, 255, 204)
Flag_there_are_spaces_in_the_target_language_cell = 1 '''目标语言单元格存在空格
End If
Next cell
'''【恢复】某个网页的内容
'读取当前选择的文件名和路径
'
iFile_Tatol_Name1 = Cells(1, 3)
iFile_Name1 = Cells(1, 2)
iFILE_PATH1 = Cells(1, 1)
'目标语言的文件名和路径
'
'读取目标语言 '
tLang = Function_Get_Target_Lang(Cells(21, 2))
If tLang = "nonono_Lang" Then
MsgBox "目标语言为空,,, 请选择先,,"
Exit Sub
Else
End If
If InStr(iFILE_PATH1, "\" & tLang) Then '错误地 选了目标语言的文件,
MsgBox "错误地选了某个目标语言的文件,xxxxxx, 要求选择源语言文件。。。"
Exit Sub
Else
Subdirectory_Name = "News" '子目录名字
If InStr(iFILE_PATH1, Subdirectory_Name) Then
iFile_Name2 = iFile_Name1 '目标文件名
iFILE_PATH2 = Left(iFILE_PATH1, InStr(iFILE_PATH1, "\" & Subdirectory_Name) - 1) & "\" & tLang '目标路径
iFile_Tatol_Name2 = iFILE_PATH2 & "\" & Subdirectory_Name & "\" & iFile_Name2 '目标文件名的全路径
Else
iFile_Name2 = iFile_Name1 '目标文件名
iFILE_PATH2 = iFILE_PATH1 & "\" & tLang '目标路径
iFile_Tatol_Name2 = iFILE_PATH2 & "\" & iFile_Name2 '目标文件名的全路径
End If
End If
'读文件内容,并修改/替换 局部内容
xText = ReadFileTe000xt000("E:\, G-0501\临时某个页面的代码.html")
'写文件
Call WriteFileText(xText, iFile_Tatol_Name2) ''
MsgBox "lastRow_K:" & str(lastRow_K) & vbCrLf & "K列【最后一行往上看】的 范围内 存在【空白】单元格。" & vbCrLf & vbCrLf & "提前退出..【把目标语言词组写入源文件】函数......." & vbCrLf & "【建议换一个翻译软件】" & vbCrLf & "【建议换一个翻译软件】" & vbCrLf & "【建议换一个翻译软件】" & vbCrLf & "【建议换一个翻译软件】" & vbCrLf & "【建议换一个翻译软件】"
Exit Sub
Else
' MsgBox "范围内没有空白单元格。"
End If
''判断连续的几个单元格中有没有空白的单元格存在,
lastRow_J = MaxUsedRowInCol("J") + 0
lastRow_K = MaxUsedRowInCol("K") + 0
If lastRow_J < lastRow_K Then ''''目标语言的内容 多于 原始的语言内容的单元格数目
K_More_then_J = 1
'''【恢复】某个网页的内容
'读取当前选择的文件名和路径
'
iFile_Tatol_Name1 = Cells(1, 3)
iFile_Name1 = Cells(1, 2)
iFILE_PATH1 = Cells(1, 1)
'目标语言的文件名和路径
'
'读取目标语言 '
tLang = Function_Get_Target_Lang(Cells(21, 2))
If tLang = "nonono_Lang" Then
MsgBox "目标语言为空,,, 请选择先,,"
Exit Sub
Else
End If
If InStr(iFILE_PATH1, "\" & tLang) Then '错误地 选了目标语言的文件,
MsgBox "错误地选了某个目标语言的文件,xxxxxx, 要求选择源语言文件。。。"
Exit Sub
Else
Subdirectory_Name = "News" '子目录名字
If InStr(iFILE_PATH1, Subdirectory_Name) Then
iFile_Name2 = iFile_Name1 '目标文件名
iFILE_PATH2 = Left(iFILE_PATH1, InStr(iFILE_PATH1, "\" & Subdirectory_Name) - 1) & "\" & tLang '目标路径
iFile_Tatol_Name2 = iFILE_PATH2 & "\" & Subdirectory_Name & "\" & iFile_Name2 '目标文件名的全路径
Else
iFile_Name2 = iFile_Name1 '目标文件名
iFILE_PATH2 = iFILE_PATH1 & "\" & tLang '目标路径
iFile_Tatol_Name2 = iFILE_PATH2 & "\" & iFile_Name2 '目标文件名的全路径
End If
End If
'读文件内容,并修改/替换 局部内容
xText = ReadFileTe000xt000("E:\, G-0501\临时某个页面的代码.html")
'写文件
Call WriteFileText(xText, iFile_Tatol_Name2) ''
MsgBox "lastRow_J:" & str(lastRow_J) & vbCrLf & "lastRow_K:" & str(lastRow_K) & vbCrLf & vbCrLf & "K列,目标语言的内容 多于 原始的语言内容的单元格数目。" & vbCrLf & vbCrLf & "提前退出..【把目标语言词组写入源文件】函数......." & vbCrLf & "【建议换一个翻译软件】" & vbCrLf & "【建议换一个翻译软件】" & vbCrLf & "【建议换一个翻译软件】" & vbCrLf & "【建议换一个翻译软件】" & vbCrLf & "【建议换一个翻译软件】"
Exit Sub
Else
' MsgBox "范围内没有空白单元格。"
End If
Application.ScreenUpdating = False
Set sheet = ActiveWorkbook.Sheets("解析网页,提炼词组,翻译词组,写入文件")
'读取目标语言 '
tLang = Function_Get_Target_Lang(Cells(21, 2))
If tLang = "nonono_Lang" Then
MsgBox "目标语言为空,,, 请选择先,,"
Exit Sub
Else
End If
Call 加水印__AddWatermarkForExcel2003(Cells(21, 2)) '''加水印 内容
G_Row = 1
G_Col = 4 'D列
'读取当前选择的文件名和路径
'
iFile_Tatol_Name1 = Cells(1, 3)
iFile_Name1 = Cells(1, 2)
iFILE_PATH1 = Cells(1, 1)
'目标语言的文件名和路径
'
If InStr(iFILE_PATH1, "\" & tLang) Then '错误地 选了目标语言的文件,
MsgBox "错误地选了某个目标语言的文件,xxxxxx, 要求选择源语言文件。。。"
Exit Sub
Else
Subdirectory_Name = "News" '子目录名字
If InStr(iFILE_PATH1, Subdirectory_Name) Then
iFile_Name2 = iFile_Name1 '目标文件名
iFILE_PATH2 = Left(iFILE_PATH1, InStr(iFILE_PATH1, "\" & Subdirectory_Name) - 1) & "\" & tLang '目标路径
iFile_Tatol_Name2 = iFILE_PATH2 & "\" & Subdirectory_Name & "\" & iFile_Name2 '目标文件名的全路径
Else
iFile_Name2 = iFile_Name1 '目标文件名
iFILE_PATH2 = iFILE_PATH1 & "\" & tLang '目标路径
iFile_Tatol_Name2 = iFILE_PATH2 & "\" & iFile_Name2 '目标文件名的全路径
End If
End If
'更新 目标那行的总行数
lastRow_E = MaxUsedRowInCol("E") + 0
nnn = lastRow_E
'排序,
'
Range("E1:K" & Trim(str(nnn))).Select
Range("E" & Trim(str(nnn))).Activate
Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Key2:=Range("F1"), Order2:=xlAscending, Key3:=Range("H1"), Order3:=xlAscending, header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Range("H5").Select
Range("E" & Trim(str(1)) & ":I" & Trim(str(nnn))).Interior.Color = RGB(255, 255, 255) ''白色
'目标语言词组为空,则跳出, '
If Range("K" & Trim(str(1))) = "" Then
MsgBox "目标语言词组的【内容】为空,,," & vbCrLf & vbCrLf & " 请先 从Google浏览器 复制 一下,,"
Exit Sub
Else
End If
''''''''''''''''''''读文件
' Dim Ii
' Dim AD As Object: Set AD = CreateObject("ADODB.Stream")
' AD.Charset = "utf-8"
' AD.Open
' AD.LoadFromFile iFile_Tatol_Name2
' xText = AD.readText
' AD.Close
'读文件内容,并修改/替换 局部内容
xText = ReadFileTe000xt000(iFile_Tatol_Name2)
'更新 目标语言的行数 ,,,有可能是【分几次】翻译单元格的内容
'
lastRow_J = MaxUsedRowInCol("J")
lastRow_K = MaxUsedRowInCol("K")
If lastRow_J = lastRow_K Then
nnn = lastRow_K
Else
nnn = lastRow_K - 1
End If
nnn = nnn ''MaxUsedRowInCol("K")
''
For i = 1 To nnn
If Range("J" & Trim(str(i))) = "" Then 'J列,, 优化的词组
MsgBox "第" & str(i) & "行 的【J】单元格 str(cells(i,10)) 为空格,..请检查。。。 "
Exit For
Else
'
'更改文件开头地方的语言的短语字符段
'
xText = Replace(xText, "", "")
' If Range("H" & Trim(str(i))) <> Range("J" & Trim(str(i))) Then '有超链接, 如:1)文本超链接, 2)粗体Strong
tHH = Range("F" & Trim(str(i))) & Range("H" & Trim(str(i))) & Range("I" & Trim(str(i)))
tJJ = Range("F" & Trim(str(i))) & Range("J" & Trim(str(i))) & Range("I" & Trim(str(i)))
tKK = Range("F" & Trim(str(i))) & Range("K" & Trim(str(i))) & Range("I" & Trim(str(i)))
' Else
' tHH = Range("F" & Trim(str(i))) & Range("J" & Trim(str(i))) & Range("I" & Trim(str(i)))
' tKK = Range("F" & Trim(str(i))) & Range("K" & Trim(str(i))) & Range("I" & Trim(str(i)))
' End If
'
' If Cells(i, 10) = "There is no best only better.Any need please feel free to Contact us, we are confident to meet your needs. Thank you for your support and trust to create a better future." Then
'
' xText = xText ' MsgBox xText
' Else
' xText = xText ' MsgBox xText
' End If
If InStr(xText, tJJ) > 0 Then ''''简单字符串 替换,无特殊 字体效果
If InStr(tJJ, "The prototyping time for bonded laminates usually takes about") > 0 Then
tJJ = tJJ
Else
tJJ = tJJ
End If
Range("O" & Trim(str(i))) = tJJ
Range("P" & Trim(str(i))) = tKK
xText = Replace(xText, tJJ, tKK)
If InStr(xText, tKK) > 0 Then
tJJ = tJJ
''''''''''''''''''''写文件
' Call WriteFileText(xText, iFile_Tatol_Name2) ''覆盖原文件,,
Else
tJJ = tJJ
End If
Range("E" & Trim(str(i)) & ":I" & Trim(str(i))).Interior.Color = RGB(255, 192, 203) '' 粉色 (Pink)
Range("U" & Trim(str(i))) = "RGB(255, 192, 203) '' 粉色 (Pink) "
ElseIf InStr(xText, tHH) > 0 Then ''''字符串 有 特殊 字体效果
xText = Replace(xText, tHH, tKK)
Range("E" & Trim(str(i)) & ":I" & Trim(str(i))).Interior.Color = RGB(65, 105, 225) '' 皇家蓝/宝蓝
Range("U" & Trim(str(i))) = "RGB(65, 105, 225) '' 皇家蓝/宝蓝"
Else
xMark = Cells(i, 5)
If xMark = "2)导航部分" Then
'特定词组
L1 = InStr(xText, "")
L2 = InStr(L1, xText, "")
DDD1 = Left(xText, L1 - 1) '
DDD2 = Mid(xText, L1, (L2 - L1)) '
DDD3 = Right(xText, Len(xText) - (L2 - 1)) '
If InStr(DDD2, Cells(i, 11) & "<") Then '已经 翻译了
' DDD2 = Replace(DDD2, Cells(i, 8) & "<", Cells(i, 11) & "<")
xText = DDD1 & DDD2 & DDD3
Range("E" & Trim(str(i)) & ":I" & Trim(str(i))).Select
With Selection.Interior
.ColorIndex = xlNone
.Pattern = xlSolid
End With
Else
DDD2 = Replace(DDD2, Cells(i, 8) & "<", Cells(i, 11) & "<")
xText = DDD1 & DDD2 & DDD3
Range("E" & Trim(str(i)) & ":I" & Trim(str(i))).Interior.Color = RGB(230, 230, 250) ''淡紫色/熏衣草淡紫
Range("U" & Trim(str(i))) = "RGB(230, 230, 250) ''淡紫色/熏衣草淡紫"
End If
ElseIf xMark = "3)Body部分" Then
tHH = Range("F" & Trim(str(i))) & Range("H" & Trim(str(i))) & Range("I" & Trim(str(i)))
tKK = Range("F" & Trim(str(i))) & Range("K" & Trim(str(i))) & Range("I" & Trim(str(i)))
If InStr(xText, tHH) Then
xText = Replace(xText, tHH, tKK)
Range("E" & Trim(str(i)) & ":I" & Trim(str(i))).Interior.Color = RGB(147, 112, 219) ''中紫色
Range("U" & Trim(str(i))) = "RGB(147, 112, 219) ''中紫色"
Else
End If
ElseIf xMark = "4)Foot部分" Then
'特定词组
L1 = InStr(xText, "
") '''特定界限,,,
DDD1 = Left(xText, L1 - 1) '
DDD2 = Mid(xText, L1, (L2 - L1)) '
DDD3 = Right(xText, Len(xText) - (L2 - 1)) '
If InStr(DDD2, Cells(i, 11) & "<") Then '已经 翻译了
' DDD2 = Replace(DDD2, Cells(i, 8) & "<", Cells(i, 11) & "<")
xText = DDD1 & DDD2 & DDD3
Range("E" & Trim(str(i)) & ":I" & Trim(str(i))).Interior.Color = RGB(255, 255, 255) ''白色
Else
DDD2 = Replace(DDD2, Cells(i, 8) & "<", Cells(i, 11) & "<")
xText = DDD1 & DDD2 & DDD3
Range("E" & Trim(str(i)) & ":I" & Trim(str(i))).Interior.Color = RGB(255, 239, 213) ''番木色/番木瓜
Range("U" & Trim(str(i))) = "RGB(255, 239, 213) ''番木色/番木瓜"
End If
Else
End If
End If
End If
Next
''''''''''''''''''''写文件
Call WriteFileText(xText, iFile_Tatol_Name2) ''覆盖原文件,,
Range("A138:C138").Select '''这几个单元格,插入一行的地方,往下移
Range("C138").Activate
Selection.Insert Shift:=xlDown
' Rows("138:138").Select
' Selection.Insert Shift:=xlDown
Range("A138").Select
ActiveCell.FormulaR1C1 = Now()
Range("B138").Select
ActiveCell.FormulaR1C1 = xLanguge___No_Str
Range("C138").Select
ActiveCell.FormulaR1C1 = iFile_Tatol_Name2
ActiveWindow.LargeScroll Up:=3, ToLeft:=3 ''' "将当前窗口向上滚动3页并向左滚动3页"
n2 = n2
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function 提炼字符串(ByVal xMark As String, ByVal xText As String, ByVal t1 As String, ByVal t1R As String, ByVal t2 As String, ByVal MM As Long, ByVal L1 As Long, ByVal L2 As Long, ByVal nKK As Long, ByVal xG_Row As Long, ByVal xG_Col As Long, ByVal iifile_name As String, ByVal iFILE_NAME_1 As String, ByVal iFILE_PATH_1 As String) As Long
'
Dim sheet As Worksheet
Dim Mark_Cell, Beg_Cell, Beg2_Cell, End_Cell, Text_Cell, Text_Cell_Optimize, s As Range
Dim n03, n1, n11, n12, n13, n14, n15, n16, n17, n18, n19, n20, n2, iFind_the_string As Long
Dim yy, yText, xxxxTest, MID_STR As String
Dim n01, n02, n1R As Long
Dim ssssss
Set sheet = ActiveWorkbook.Sheets("解析网页,提炼词组,翻译词组,写入文件")
Set Mark_Cell = sheet.Range("E" & G_Row)
Set Beg_Cell = sheet.Range("F" & G_Row)
Set Beg2_Cell = sheet.Range("G" & G_Row)
Set End_Cell = sheet.Range("I" & G_Row)
Set Text_Cell = sheet.Range("H" & G_Row)
Set Text_Cell_Optimize = sheet.Range("J" & G_Row) '优化后的词组, 如:1)超链接contact us , 2)粗体strong
'有效数据加以限制
'
yText = Left(xText, L2)
提炼字符串 = MM
If xMark = "1)头部" Then
'过滤特定词组
'
If MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
ElseIf MM = InStr(MM, yText, "") Then
提炼字符串 = MM + 1
Else
If t1 = "
Backlack - connection technology for perfect laminations!
'
There is no best only better.Any need please feel free to Contact us, we are confident to meet your needs. Thank you for your support and trust to create a better future.
'
There is no best only better.Any need please feel free to Contact us, we ...ture.
Features such as a beautiful metallic appearance, high corrosion resistance, wear resistance, low paper friction, scratch resistance and fingerprint resistance, have led to an excellent reputation for this unpainted galvanized steel sheet for many years.